Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/logo/part03

Internet Message Format | 1987-06-23 | 47.4 KB

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i023: Logo interpreter for Unix, Part03/06
Message-ID: <[e-mail]>
Date: 24 Jun 87 20:21:46 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 2537
Approved: [e-mail]

Submitted by: Brian Harvey <bh@mit-amt>
Mod.Sources: Volume 10, Number 23
Archive-Name: logo/Part03

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 3 (of 6)."
# Contents:  logoaux.c logoop.c logoproc.c turtle.c
# Wrapped by [e-mail] on Wed Jun 24 14:26:57 1987
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f logoaux.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"logoaux.c\"
else
echo shar: Extracting \"logoaux.c\" \(11138 characters\)
sed "s/^X//" >logoaux.c <<'END_OF_logoaux.c'
X
X/*    This file contains a miscellany of functions for LOGO, both
X * primary implementation of LOGO operations and commands, and also various
X * other functions for maintaining the overhead of the interpreter (variable
X * storage, function calls, etc.)
X *
X *    Copyright (C) 1979, The Children's Museum, Boston, Mass.
X *    Written by Douglas B. Klunder
X */
X
X#include "logo.h"
X#include <sgtty.h>
X#include <setjmp.h>
Xextern jmp_buf yerrbuf;
Xint tvec[2] ={0,0};
Xextern int yychar,yylval,yyline;
Xextern int topf,errtold,flagquit;
Xextern FILE *ofile;
Xextern char *ostring;
Xextern char *getbpt;
Xextern char charib;
Xextern int pflag,letflag;
Xextern int currtest;
Xstruct runblock *thisrun = NULL;
Xextern struct plist *pcell;    /* for PAUSE */
Xextern struct stkframe *fbr;
X#ifdef PAUSE
Xextern int pauselev,psigflag;
X#endif
X
Xtyobj(text)
Xregister struct object *text;
X{
X    register struct object *temp;
X    char str[30];
X
X    if (text==0) return;
X    switch (text->obtype) {
X        case CONS:
X            for (temp = text; temp; temp = temp->obcdr) {
X                fty1(temp->obcar);
X                if(temp->obcdr) putc1(' ');
X            }
X            break;
X        case STRING:
X            sputs(text->obstr);
X            break;
X        case INT:
X            sprintf(str,FIXFMT,text->obint);
X            sputs(str);
X            break;
X        case DUB:
X            sprintf(str,"%g",text->obdub);
X            if (!index(str,'.')) strcat(str,".0");
X            sputs(str);
X            break;
X    }
X}
X
Xfty1(text)
Xregister struct object *text;
X{
X    if (listp(text)) {
X        putc1('[');
X        tyobj(text);
X        putc1(']');
X    } else tyobj(text);
X}
X
Xfillbuf(text)    /* Logo TYPE */
Xregister struct object *text;
X{
X    tyobj(text);
X    mfree(text);
X}
X
Xstruct object *cmprint(arg)
Xstruct object *arg;
X{
X    fillbuf(arg);
X    putchar('\n');
X    return ((struct object *)(-1));
X}
X
Xstruct object *cmtype(arg)
Xstruct object *arg;
X{
X    fillbuf(arg);
X    return ((struct object *)(-1));
X}
X
Xstruct object *cmfprint(arg)
Xstruct object *arg;
X{
X    fty1(arg);
X    putchar('\n');
X    mfree(arg);
X    return ((struct object *)(-1));
X}
X
Xstruct object *cmftype(arg)
Xstruct object *arg;
X{
X    fty1(arg);
X    mfree(arg);
X    return ((struct object *)(-1));
X}
X
Xsetfile(file)
Xregister struct object *file;
X{
X    file = numconv(file,"File command");
X    if (!intp(file)) ungood("File command",file);
X    ofile = (FILE *)((int)(file->obint));
X    mfree(file);
X}
X
Xfileprint(file,text)
Xregister struct object *file,*text;
X{
X    setfile(file);
X    fillbuf(text);
X    fputc('\n',ofile);
X    ofile = NULL;
X}
X
Xfilefprint(file,text)
Xregister struct object *file,*text;
X{
X    setfile(file);
X    fty1(text);
X    mfree(text);
X    fputc('\n',ofile);
X    ofile = NULL;
X}
X
Xfiletype(file,text)
Xregister struct object *file,*text;
X{
X    setfile(file);
X    fillbuf(text);
X    ofile = NULL;
X}
X
Xfileftype(file,text)
Xstruct object *file,*text;
X{
X    setfile(file);
X    fty1(text);
X    mfree(text);
X    ofile = NULL;
X}
X
Xstruct object *openfile(name,type)
Xregister struct object *name;
Xregister char *type;
X{
X    FILE *fildes;
X
X    if (!stringp(name)) ungood("Open file",name);
X    fildes = fopen(name->obstr,type);
X    if (!fildes) {
X        pf1("Can't open file %l.\n",name);
X        errhand();
X    }
X    mfree(name);
X    return(localize(objint((FIXNUM)((int)fildes))));
X}
X
Xstruct object *loread(arg)
Xstruct object *arg;
X{
X    return(openfile(arg,"r"));
X}
X
Xstruct object *lowrite(arg)
Xstruct object *arg;
X{
X    return(openfile(arg,"w"));
X}
X
Xstruct object *callunix(cmd)
Xregister struct object *cmd;
X{
X    register struct object *str;
X
X    str = stringform(cmd);
X    system(str->obstr);
X    mfree(str);
X    mfree(cmd);
X    return ((struct object *)(-1));
X}
X
Xstruct object *fileclose(file)
Xregister struct object *file;
X{
X    setfile(file);
X    fclose(ofile);
X    ofile = NULL;
X    return ((struct object *)(-1));
X}
X
Xstruct object *fileread(file,how)
Xregister struct object *file;
Xint how; /* 0 for fileread (returns list), 1 for fileword (returns str) */
X{
X    char str[200];
X    register struct object *x;
X    char *svgbpt;
X    char c;
X
X    setfile(file);
X    fgets(str,200,ofile);
X    if (feof(ofile)) {
X        ofile = NULL;
X        if (how) return((struct object *)0);
X        return(localize(objcpstr("")));
X    }
X    ofile = NULL;
X    if (how) {
X        str[strlen(str)-1] = '\0';
X        return(localize(objcpstr(str)));
X    }
X    str[strlen(str)-1] = ']';
X    c = charib;
X    charib = 0;
X    svgbpt = getbpt;
X    getbpt = str;
X    x = makelist();
X    getbpt = svgbpt;
X    charib = c;
X    return(x);
X}
X
Xstruct object *lfread(arg)
Xstruct object *arg;
X{
X    return(fileread(arg,0));
X}
X
Xstruct object *lfword(arg)
Xstruct object *arg;
X{
X    return(fileread(arg,1));
X}
X
Xstruct object *lsleep(tim)    /* wait */
Xregister struct object *tim;
X{
X    int itim;
X
X    tim = numconv(tim,"Wait");
X    if (intp(tim)) itim = tim->obint;
X    else itim = tim->obdub;
X    mfree(tim);
X    sleep(itim);
X    return ((struct object *)(-1));
X}
X
Xstruct object *input(flag)
Xint flag;    /* 0 for readlist, 1 for request */
X{
X    int len;
X    char s[512];
X    register struct object *x;
X    char *svgbpt;
X    char c;
X
X    if (flag) putchar('?');
X    fflush(stdout);
X    len = read(0,s,512);
X    if (len <= 0) len = 1;
X    s[len-1]=']';
X    c = charib;
X    charib = 0;
X    svgbpt = getbpt;
X    getbpt = s;
X    x = makelist();
X    getbpt = svgbpt;
X    charib = c;
X    return (x);
X}
X
Xstruct object *readlist() {
X    return(input(0));
X}
X
Xstruct object *request() {
X    return(input(1));
X}
X
Xstruct object *ltime()        /* LOGO time */
X{
X    char ctim[50];
X    register struct object *x;
X    char *svgbpt;
X    char c;
X
X    time(tvec);
X    strcpy(ctim,ctime(tvec));
X    ctim[strlen(ctim)-1]=']';
X    c = charib;
X    charib = 0;
X    svgbpt = getbpt;
X    getbpt = ctim;
X    x = makelist();
X    getbpt = svgbpt;
X    charib = c;
X    return(x);
X}
X
Xdorun(arg,num)
Xstruct object *arg;
XFIXNUM num;
X{
X    register struct object *str;
X    register struct runblock *rtemp;
X
X    rtemp = (struct runblock *)ckmalloc(sizeof(struct runblock));
X    if (num != 0) {
X        rtemp->rcount = num;
X        rtemp->rupcount = 0;
X    } else {
X        rtemp->rcount = 1;    /* run or if, not repeat */
X         if (thisrun)
X             rtemp->rupcount = thisrun->rupcount - 1;
X         else
X             rtemp->rupcount = 0;
X    }
X    rtemp->roldyyc = yychar;
X    rtemp->roldyyl = yylval;
X    rtemp->roldline = yyline;
X    rtemp->svbpt = getbpt;
X    rtemp->svpflag = pflag;
X    rtemp->svletflag = letflag;
X    rtemp->svch = charib;
X    if (arg == (struct object *)(-1)) {    /* PAUSE */
X        rtemp->str = (struct object *)(-1);
X    } else {
X        str = stringform(arg);
X        mfree(arg);
X        strcat(str->obstr,"\n");
X        rtemp->str = globcopy(str);
X        mfree(str);
X    }
X    rtemp->rprev = thisrun;
X    thisrun = rtemp;
X    rerun();
X}
X
Xrerun() {
X    yychar = -1;
X    pflag = 0;
X    letflag = 0;
X    charib = '\0';
X    thisrun->rupcount++;
X    if (thisrun->str == (struct object *)(-1))    /* PAUSE */
X        getbpt = 0;
X    else
X        getbpt = thisrun->str->obstr;
X}
X
Xunrun() {
X    register struct runblock *rtemp;
X
X    yychar = thisrun->roldyyc;
X    yylval = thisrun->roldyyl;
X    yyline = thisrun->roldline;
X    getbpt = thisrun->svbpt;
X    pflag = thisrun->svpflag;
X    letflag = thisrun->svletflag;
X    charib = thisrun->svch;
X    if (thisrun->str != (struct object *)(-1))    /* PAUSE */
X        lfree(thisrun->str);
X    rtemp = thisrun;
X    thisrun = thisrun->rprev;
X    JFREE(rtemp);
X}
X
Xdorep(count,cmd)
Xstruct object *count,*cmd;
X{
X    FIXNUM icount;
X
X    count = numconv(count,"Repeat");
X    if (intp(count)) icount = count->obint;
X    else icount = count->obdub;
X    if (icount < (FIXNUM)0) ungood("Repeat",count);
X    if (icount == (FIXNUM)0) {
X        mfree(cmd);
X        cmd = 0;
X        icount++;
X    }
X    dorun(cmd,icount);
X    mfree(count);
X}
X
Xstruct object *repcount() {
X    if (!thisrun) {
X        puts("Repcount outside repeat.");
X        errhand();
X    }
X    return(localize(objint(thisrun->rupcount)));
X}
X
X#ifdef PAUSE
Xdopause() {
X    register struct plist *opc;
X
X    if (pflag || getbpt) {
X        printf("Pausing");
X        opc = pcell;
X        if (fbr && fbr->oldline==-1) {
X            opc=fbr->prevpcell;
X        }
X        if (opc&&!topf) printf(" at line %d in procedure %s",yyline,
X                opc->procname->obstr);
X        printf("\n");
X        pauselev++;
X    }
X    if (psigflag) {
X        psigflag = 0;
X#ifdef EUNICE
X        yyprompt();
X#endif
X    }
X    if (pflag || getbpt)
X        dorun((struct object *)(-1),(FIXNUM)0);
X}
X
Xunpause() {
X    if (pauselev > 0) {
X        pauselev--;
X        unrun();
X    }
X}
X#endif
X
Xerrhand()    /* do error recovery, then pop out to outer level */
X{
X    errtold++;
X    flagquit = 0;
X    onintr(errrec,1);
X#ifdef PAUSE
X    longjmp(yerrbuf,9);
X#else
X    ltopl();
X#endif
X}
X
Xnullfn()
X{
X}
X
Xreadlin(fd,buf)        /* read a line from file */
Xregister FILDES fd;
Xregister char *buf;
X{
X    register char *i;
X
X    for (i = buf; *(i-1) != '\n'; i++) read(fd,i,1);
X}
X
Xmakeup(str)
Xregister char *str;
X{
X    register char ch;
X
X    while (ch = *str) {
X        if (ch >= 'a' && ch <= 'z') *str = ch-040;
X        str++;
X    }
X}
X
Xstruct object *cbreak(ostr)
Xregister struct object *ostr;
X{
X    struct sgttyb sgt;
X    register char *str;
X
X#ifdef CBREAK
X    if (!stringp(ostr)) ungood("Cbreak",ostr);
X    str = ostr->obstr;
X    makeup(str);
X    if (strcmp(str,"ON") && strcmp(str,"OFF")) {
X        puts("cbreak input must be \"on or \"off");
X        errhand();
X    }
X    gtty(0,&sgt);
X    if (!strcmp(str,"ON")) {
X        sgt.sg_flags |= CBREAK;
X        sgt.sg_flags &= ~ECHO;
X    } else {
X        sgt.sg_flags &= ~CBREAK;
X        sgt.sg_flags |= ECHO;
X    }
X    stty(0,&sgt);
X    mfree(ostr);
X    return ((struct object *)(-1));
X#else
X    printf("No CBREAK on this system.\n");
X    errhand();    /* Such as V6 or Idris */
X#endif
X}
X
Xcboff()
X{
X    struct sgttyb sgt;
X
X#ifdef CBREAK
X    gtty(0,&sgt);
X    sgt.sg_flags &= ~CBREAK;
X    sgt.sg_flags |= ECHO;
X    stty(0,&sgt);
X#endif
X}
X
Xstruct object *readchar()
X{
X    char s[2];
X
X    fflush(stdout);
X    read(0,s,1);
X    s[1] = '\0';
X    return(localize(objcpstr(s)));
X}
X
Xstruct object *keyp()
X{
X#ifdef TIOCEMPTY
X    int i;
X
X    fflush(stdout);
X    ioctl(0,TIOCEMPTY,&i);
X    if (i)
X        return(true());
X    else
X#else
X#ifdef FIONREAD
X    long i;
X
X    fflush(stdout);
X    ioctl(0,FIONREAD,&i);
X    if (i)
X        return(true());
X    else
X#endif
X#endif
X        return(false());
X}
X
Xstruct object *settest(val)
Xstruct object *val;
X{
X    if (obstrcmp(val,"true") && obstrcmp(val,"false")) ungood("Test",val);
X    currtest = !obstrcmp(val,"true");
X    mfree(val);
X    return ((struct object *)(-1));
X}
X
Xloflush() {
X    fflush(stdout);
X}
X
Xstruct object *cmoutput(arg)
Xstruct object *arg;
X{
X    extern int endflag;
X
X#ifdef PAUSE
X    if (!pflag && thisrun && thisrun->str==(struct object *)(-1))
X        unpause();
X#endif
X    endflag = 1;
X    return(arg);
X}
X
X#ifdef SETCURSOR
X
Xint gotterm = 0;
X
X/* Termcap definitions */
X
Xchar    *UP,
X    *CS,
X    *CM,
X    *CL,
X    *BC,
X    *padchar;
X
Xchar    PC = '\0';
X
Xshort ospeed;
X
Xchar    tspace[128];
X
Xchar **meas[] = {
X    &CS, &CM, &CL, &UP, &BC, &padchar, 0
X};
X
Xchar    tbuff[1024];
X
XgetTERM()
X{
X    char    *getenv();
X    struct sgttyb tty;
X    char    *ts="cscmclupbcpc";
X    char    *termname = 0,
X        *termp = tspace;
X    int    i;
X
X    if (gotterm) return(gotterm);
X
X    if (gtty(1, &tty)) {
X        ospeed = B1200;
X    } else {
X        tty.sg_flags &= ~ XTABS;
X        ospeed = tty.sg_ospeed;
X        stty(1,&tty);
X    }
X
X    termname = getenv("TERM");
X    if (termname == 0) {
X        puts("No terminal in environment.");
X        gotterm = -1;
X        return(gotterm);
X    }
X
X    if (tgetent(tbuff, termname) < 1) {
X        pf1("No termcap entry for %s\n",termname);
X        gotterm = -1;
X        return(gotterm);
X    }
X
X    for (i = 0; meas[i]; i++) {
X        *(meas[i]) = (char *) tgetstr(ts, &termp);
X        ts += 2;
X    }
X
X    if (padchar) PC = *padchar;
X
X    gotterm = 1;
X    return(gotterm);
X}
X
Xextern int putch();
X
Xstruct object *clrtxt()
X{
X    if (getTERM() < 0) return;
X    tputs(CL,24,putch);
X    return ((struct object *)(-1));
X}
X
Xstruct object *setcur(x,y)
Xstruct object *x,*y;
X{
X    int ix,iy;
X
X    x=numconv(x,"Setcursorxy");
X    y=numconv(y,"Setcursorxy");
X    if (!intp(x)) ungood("Setcursorxy",x);
X    if (!intp(y)) ungood("Setcursorxy",y);
X    if (getTERM() > 0) {
X        ix = x->obint;
X        iy = y->obint;
X        tputs(tgoto(CM,ix,iy),1,putch);
X    }
X    mfree(x);
X    mfree(y);
X    return ((struct object *)(-1));
X}
X
X#endif SETCURSOR
X
END_OF_logoaux.c
if test 11138 -ne `wc -c <logoaux.c`; then
    echo shar: \"logoaux.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f logoop.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"logoop.c\"
else
echo shar: Extracting \"logoop.c\" \(10685 characters\)
sed "s/^X//" >logoop.c <<'END_OF_logoop.c'
X
X/*    Miscellaneous operations in LOGO.
X *    Copyright (C) 1979, The Children's Museum, Boston, Mass.
X *    Written by Douglas B. Klunder.
X */
X
X#include "logo.h"
X
Xstruct object *true()
X{
X    return(localize(objcpstr("true")));
X}
X
Xstruct object *false()
X{
X    return(localize(objcpstr("false")));
X}
X
Xobstrcmp(obj,str)
Xregister struct object *obj;
Xchar *str;
X{
X    if (!stringp(obj)) return(1);
X    return(strcmp(obj->obstr,str));
X}
X
Xint truth(x)    /* used by if handler in logo.y */
Xregister struct object *x;
X{
X    if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("If",x);
X    if (!obstrcmp(x,"true")) {
X        mfree(x);
X        return(1);
X    } else {
X        mfree(x);
X        return(0);
X    }
X}
X
Xchar *mkstring(obj)
Xregister struct object *obj;
X{
X    /* subroutine for several operations which treat numbers as words,
X     * turn number into character string.
X     * Note: obj must be known to be nonempty; result is ptr to static.
X     */
X
X    register char *cp;
X    static char str[30];
X
X    switch(obj->obtype) {
X        case STRING:
X            cp = obj->obstr;
X            break;
X        case INT:
X            sprintf(str,FIXFMT,obj->obint);
X            cp = str;
X            break;
X        case DUB:
X            sprintf(str,"%g",obj->obdub);
X            if (!index(str,'.')) strcat(str,".0");
X            cp = str;
X            break;
X        default:    /* case CONS */
X            return(0);    /* not a string, handle uplevel */
X    }
X    return(cp);
X}
X
Xstruct object *and(x,y)        /* both */
Xregister struct object *x,*y;
X{
X    if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("Both",x);
X    if (obstrcmp(y,"true") && obstrcmp(y,"false")) ungood("Both",y);
X    if (!obstrcmp(x,"true")) {
X        mfree(x);
X        return(y);
X    } else {
X        mfree(y);
X        return(x);
X    }
X}
X
Xstruct object *or(x,y)        /* either */
Xregister struct object *x,*y;
X{
X    if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("Either",x);
X    if (obstrcmp(y,"true") && obstrcmp(y,"false")) ungood("Either",y);
X    if (!obstrcmp(x,"true")) {
X        mfree(y);
X        return(x);
X    } else {
X        mfree(x);
X        return(y);
X    }
X}
X
Xemptyp(x)    /* non-LOGO emptyp, returning 1 if empty, 0 if not. */
Xregister struct object *x;
X{
X    if (x==0) return(1);
X    switch (x->obtype) {
X        case STRING:
X            if (*(x->obstr)=='\0')    /* check for character */
X                return(1);
X        default:
X            return(0);
X    }
X}
X
Xstruct object *lemp(x)        /* LOGO emptyp */
Xregister struct object *x;
X{
X    if (emptyp(x)) {
X        mfree(x);
X        return(true());
X    } else {
X        mfree(x);
X        return(false());
X    }
X}
X
Xstruct object *comp(x)        /* not */
Xregister struct object *x;
X{
X    if (!obstrcmp(x,"true")) {
X        mfree(x);
X        return(false());
X    } else if (!obstrcmp(x,"false")) {
X        mfree(x);
X        return(true());
X    } else ungood("Not",x);
X}
X
Xstruct object *lsentp(x)    /* LOGO sentencep */
Xregister struct object *x;
X{
X    register struct object *y;
X
X    if (x==0) return(true());
X    if (listp(x)) {
X        /* BH 4/30/81 true only for a flat sentence,
X           not a list of lists */
X        for (y = x; y; y = y->obcdr)
X            if (listp(y->obcar)) {
X                mfree(x);
X                return(false());
X            }
X        mfree(x);
X        return(true());
X    } else {
X        mfree(x);
X        return(false());
X    }
X}
X
Xstruct object *lwordp(x)    /* LOGO wordp */
Xregister struct object *x;
X{
X    if (!listp(x)) {
X        mfree(x);
X        return(true());
X    } else {
X        mfree(x);
X        return(false());
X    }
X}
X
Xstruct object *first(x)        /* first */
Xregister struct object *x;
X{
X    register struct object *temp;
X    register char *cp;
X    char str[2];
X
X    if (emptyp(x)) ungood("First",x);
X    if (cp = mkstring(x)) {
X        str[0] = *cp;
X        str[1] = '\0';
X        mfree(x);
X        return(localize(objcpstr(str)));
X    } else {
X        temp = x->obcar;
X        localize(temp);
X        mfree(x);
X        return(temp);
X    }
X}
X
Xstruct object *butfir(x)        /* butfirst */
Xregister struct object *x;
X{
X    register struct object *temp;
X    register char *cp;
X
X    if (emptyp(x)) ungood("Butfirst",x);
X    if (cp = mkstring(x)) {
X        cp++;    /* skip first char */
X        mfree(x);
X        return(localize(objcpstr(cp)));
X    } else {
X        temp = x->obcdr;
X        localize(temp);
X        mfree(x);
X        return(temp);
X    }
X}
X
Xstruct object *last(x)        /* last */
Xregister struct object *x;
X{
X    register struct object *temp;
X    register char *cp;
X
X    if (emptyp(x)) ungood("Last",x);
X    if (cp = mkstring(x)) {
X        mfree(x);
X        return(localize(objcpstr(&cp[strlen(cp)-1])));
X    } else {
X        for(temp=x; temp->obcdr; temp=temp->obcdr) ;
X        temp = temp->obcar;
X        localize(temp);
X        mfree(x);
X        return(temp);
X    }
X}
X
Xstruct object *butlas(x)        /* butlast */
Xregister struct object *x;
X{
X    register struct object *temp,*temp2,*ans;
X    register char *cp;
X
X    if (emptyp(x)) ungood("Butlast",x);
X    if (cp = mkstring(x)) {
X        mfree(x);
X        temp = objstr(ckmalloc(strlen(cp)));
X        strncpy(temp->obstr,cp,strlen(cp)-1);
X        (temp->obstr)[strlen(cp)-1] = '\0';
X        return(localize(temp));
X    } else {
X        if ((x->obcdr)==0) {
X            mfree(x);
X            return(0);
X        }
X        temp2 = ans = globcons(0,0);
X        for(temp=x; temp->obcdr->obcdr; temp=temp->obcdr) {
X            temp2->obcar = globcopy(temp->obcar);
X            temp2->obcdr = globcopy(globcons(0,0));
X            temp2 = temp2->obcdr;
X        }
X        temp2->obcar = globcopy(temp->obcar);
X        localize(ans);
X        mfree(x);
X        return(ans);
X    }
X}
X
Xstruct object *fput(x,y)
Xregister struct object *x,*y;
X{
X    register struct object *z;
X
X    if(!listp(y)) {
X        printf("Second input of fput must be a list.\n");
X        errhand();
X    }
X    z = loccons(x,y);
X    mfree(x);
X    mfree(y);
X    return(z);
X}
X
Xstruct object *lput(x,y)
Xstruct object *x,*y;
X{
X    register struct object *a,*b,*ans;
X
X    if (!listp(y)) {
X        printf("Second input of lput must be a list.\n");
X        errhand();
X    }
X    if (y == 0) {    /* 2nd input is empty list */
X        b = loccons(x,0);
X        mfree(x);
X        return(b);
X    }
X    ans = a = loccons(0,0);
X    for (b=y; b; b=b->obcdr) {
X        a->obcar = globcopy(b->obcar);
X        a->obcdr = globcopy(globcons(0,0));
X        a = a->obcdr;
X    }
X    a->obcar = globcopy(x);
X    mfree(x);
X    mfree(y);
X    return(ans);
X}
X
Xstruct object *list(x,y)
Xstruct object *x,*y;
X{
X    register struct object *a,*b;
X
X    b = globcons(y,0);
X    a = loccons(x,b);
X    mfree(x);
X    mfree(y);
X    return(a);
X}
X
Xstruct object *length(x)        /* count */
Xregister struct object *x;
X{
X    register struct object *temp;
X    register char *cp;
X    register int i;
X
X    if (x==0) return(localize(objint((FIXNUM)0)));
X    if (cp = mkstring(x)) {
X        i = strlen(cp);
X        mfree(x);
X        return(localize(objint((FIXNUM)i)));
X    } else {
X        i = 0;
X        for (temp=x; temp; temp = temp->obcdr)
X            i++;
X        mfree(x);
X        return(localize(objint((FIXNUM)i)));
X    }
X}
X
Xlogois(x,y)        /* non-Logo is, despite the name */
Xregister struct object *x,*y;
X{
X    if (listp(x)) {
X        if (listp(y)) {
X            if (x==0) return(y==0);
X            if (y==0) return(0);
X            return(logois(x->obcar,y->obcar) &&
X                logois(x->obcdr,y->obcdr) );
X        }
X        return(0);
X    }
X    if (listp(y)) return(0);
X    if (x->obtype != y->obtype) return(0);
X    switch (x->obtype) {
X        case INT:
X            return(x->obint == y->obint);
X        case DUB:
X            return(x->obdub == y->obdub);
X        default:    /* case STRING */
X            return(!strcmp(x->obstr,y->obstr));
X    }
X}
X
Xstruct object *lis(x,y)
Xregister struct object *x,*y;
X{
X    register z;
X
X    z = logois(x,y);
X    mfree(x);
X    mfree(y);
X    return(z ? true() : false());
X}
X
Xleq(x,y)    /* non-Logo numeric equal */
Xregister struct object *x,*y;
X{
X    NUMBER dx,dy;
X    FIXNUM ix,iy;
X    int xint,yint;
X
X    if (listp(x) || listp(y)) return(logois(x,y));
X    if (stringp(x) && !nump(x)) return(logois(x,y));
X    if (stringp(y) && !nump(y)) return(logois(x,y));
X    xint = yint = 0;
X    if (stringp(x)) {
X        if (isint(x)) {
X            xint++;
X            sscanf(x->obstr,FIXFMT,&ix);
X        } else {
X            sscanf(x->obstr,EFMT,&dx);
X        }
X    } else {
X        if (intp(x)) {
X            xint++;
X            ix = x->obint;
X        } else {
X            dx = x->obdub;
X        }
X    }
X    if (stringp(y)) {
X        if (isint(y)) {
X            yint++;
X            sscanf(y->obstr,FIXFMT,&iy);
X        } else {
X            sscanf(y->obstr,EFMT,&dy);
X        }
X    } else {
X        if (intp(y)) {
X            yint++;
X            iy = y->obint;
X        } else {
X            dy = y->obdub;
X        }
X    }
X    if (xint != yint) {
X        if (xint) dx = ix;
X        else dy = iy;
X        xint = 0;
X    }
X    if (xint)
X        return (ix == iy);
X    else
X        return (dx == dy);
X}
X
Xstruct object *equal(x,y)    /* Logo equalp */
Xregister struct object *x,*y;
X{
X    register z;
X
X    z = leq(x,y);
X    mfree(x);
X    mfree(y);
X    return(z ? true() : false());
X}
X
Xstruct object *worcat(x,y)    /* word */
Xregister struct object *x,*y;
X{
X    char *val,*xp,*yp;
X    char xstr[30],ystr[30];
X
X    if (listp(x)) ungood("Word",x);
X    if (listp(y)) ungood("Word",y);
X    switch(x->obtype) {
X        case INT:
X            sprintf(xstr,FIXFMT,x->obint);
X            xp = xstr;
X            break;
X        case DUB:
X            sprintf(xstr,"%g",x->obdub);
X            if (!index(xstr,'.')) strcat(xstr,".0");
X            xp = xstr;
X            break;
X        default:    /* case STRING */
X            xp = x->obstr;
X    }
X    switch(y->obtype) {
X        case INT:
X            sprintf(ystr,FIXFMT,y->obint);
X            yp = ystr;
X            break;
X        case DUB:
X            sprintf(ystr,"%g",y->obdub);
X            if (!index(ystr,'.')) strcat(ystr,".0");
X            yp = ystr;
X            break;
X        default:    /* case STRING */
X            yp = y->obstr;
X    }
X    val=ckmalloc(strlen(xp)+strlen(yp)+1);
X    cpystr(val,xp,yp,NULL);
X    mfree(x);
X    mfree(y);
X    return(localize(objstr(val)));
X}
X
Xstruct object *sencat(x,y)    /* sentence */
Xstruct object *x,*y;
X{
X    register struct object *a,*b,*c;
X
X    if (x==0) {
X        if (listp(y)) return(y);
X        a = loccons(y,0);
X        mfree(y);
X        return(a);
X    }
X    if (listp(x)) {
X        c = a = globcons(0,0);
X        for (b=x; b->obcdr; b = b->obcdr) {
X            a->obcar = globcopy(b->obcar);
X            a->obcdr = globcopy(globcons(0,0));
X            a = a->obcdr;
X        }
X        a->obcar = globcopy(b->obcar);
X    }
X    else c = a = globcons(x,0);
X
X    if (listp(y)) b = y;
X    else b = globcons(y,0);
X
X    a->obcdr = globcopy(b);
X    mfree(x);
X    mfree(y);
X    return(localize(c));
X}
X
Xstruct object *memberp(thing,group)
Xstruct object *thing,*group;
X{
X    register char *cp;
X    register struct object *rest;
X    int i;
X
X    if (group==0) {
X        mfree(thing);
X        return(false());
X    }
X    if (cp = mkstring(group)) {
X        if (thing==0) {
X            mfree(group);
X            return(false());
X        }
X        switch (thing->obtype) {
X            case INT:
X                if((thing->obint >= 0)&&(thing->obint < 10)) {
X                    i = memb('0'+thing->obint,cp);
X                    break;
X                }
X            case CONS:
X            case DUB:
X                i = 0;
X                break;
X            default:    /* STRING */
X                if (strlen(thing->obstr) == 1) {
X                    i = memb(*(thing->obstr),cp);
X                } else i = 0;
X        }
X    } else {
X        i = 0;
X        for (rest=group; rest; rest=rest->obcdr) {
X            if (leq(rest->obcar,thing)) {
X                i++;
X                break;
X            }
X        }
X    }
X    mfree(thing);
X    mfree(group);
X    return(torf(i));
X}
X
Xstruct object *item(num,group)
Xstruct object *num,*group;
X{
X    int inum,ernum;
X    register char *cp;
X    register struct object *rest;
X    char str[2];
X
X    num = numconv(num,"Item");
X    if (intp(num)) inum = num->obint;
X    else inum = num->obdub;
X    if (inum <= 0) ungood("Item",num);
X    if (group == 0) ungood("Item",group);
X    if (cp = mkstring(group)) {
X        if (inum > strlen(cp)) {
X            pf1("%p has fewer than %d items.\n",group,inum);
X            errhand();
X        }
X        str[0] = cp[inum-1];
X        str[1] = '\0';
X        mfree(num);
X        mfree(group);
X        return(localize(objcpstr(str)));
X    } else {
X        ernum = inum;
X        for (rest = group; --inum; rest = rest->obcdr) {
X            if (rest==0) break;
X        }
X        if (rest==0) {
X            pf1("%p has fewer than %d items.\n",
X                    group,ernum);
X            errhand();
X        }
X        mfree(num);
X        rest = localize(rest->obcar);
X        mfree(group);
X        return(rest);
X    }
X}
X
END_OF_logoop.c
if test 10685 -ne `wc -c <logoop.c`; then
    echo shar: \"logoop.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f logoproc.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"logoproc.c\"
else
echo shar: Extracting \"logoproc.c\" \(11517 characters\)
sed "s/^X//" >logoproc.c <<'END_OF_logoproc.c'
X
X#include <stdio.h>
X#include "logo.h"
X
Xint errrec();
Xint ehand2();
Xint ehand3();
Xint leave();
X
Xextern char popname[];
Xextern int letflag, pflag, argno, yyline, rendflag, currtest;
Xextern int traceflag, *stkbase, stkbi, yychar, endflag, topf;
X#ifdef PAUSE
Xextern int pauselev, errpause, catching, flagquit;
X#endif
X#ifndef NOTURTLE
Xextern int turtdes;
X#endif
Xextern char charib, *getbpt, *ibufptr;
Xextern char titlebuf[];
Xextern struct lexstruct keywords[];
Xextern struct stkframe *fbr;
Xextern struct plist *proclist;
Xextern struct object *multarg;
Xextern struct runblock *thisrun;
X#ifndef YYSTYPE
X#define YYSTYPE int
X#endif
Xextern YYSTYPE yylval;
X
Xint doprep = 0;
Xint *newstk =NULL;
Xint newsti =0;
XFILE *pbuf =0;
Xstruct plist *pcell =NULL;
Xstruct alist *locptr =NULL, *newloc =NULL;
Xstruct object *allocstk[MAXALLOC] ={0};
X
Xint memb(ch,str)
Xregister char ch,*str;
X{
X    register char ch1;
X
X    while (ch1 = *str++)
X        if (ch == ch1) return(1);
X    return(0);
X}
X
Xchar *token(str)
Xregister char *str;
X{
X    static char output[NAMELEN+5];
X    register char ch,*op;
X
X    op = output;
X    while((op < &output[19]) && (ch = *str++) && !memb(ch," \t\"[\r\n:")){
X        if (ch >= 'A' && ch <= 'Z') ch += 'a'-'A';
X        *op++ = ch;
X    }
X    *op = '\0';
X    return(output);
X}
X
X#ifdef DEBUG
Xjfree(block)
Xchar *block;
X{
X    if (memtrace)
X        printf("Jfree loc=0%o\n",block);
X    if (block==0) printf("Trying to jfree zero.\n");
X    else free(block);
X}
X#endif
X
Xnewproc(nameob)
Xstruct object *nameob;
X{
X    register char *name;
X    register struct stkframe *stemp;
X    register struct lincell *ltemp;
X    struct plist *pptr;
X    int linlab;
X    int itemp;
X    char *temp,*tstr;
X    struct object *title;
X    char s[100];
X    int olp;
X    int oldlet;
X    int olc,c;
X    int pc;
X    extern struct plist *proclook();
X
X    name = nameob->obstr;
X    stemp=(struct stkframe *)ckzmalloc(sizeof(*stemp));
X    stemp->prevframe=fbr;
X    stemp->oldyyc= -2;
X    stemp->oldline= -1;
X    stemp->oldnewstk=newstk;
X    newstk = NULL;
X    stemp->oldnloc=newloc;
X    newloc=NULL;
X    stemp->argtord=argno;
X    stemp->prevpcell=pcell;
X    pcell = NULL;
X    stemp->loclist = NULL;
X    fbr=stemp;
X    doprep++;
X    argno=0;
X    if (pptr=proclook(name)) {
X        mfree(nameob);
X        newstk=pptr->realbase;
X        (pptr->recdepth)++;
X        title=pptr->ptitle;
X        pcell=pptr;
X    } else {
X        onintr(ehand2,&pbuf);
X        cpystr (s,name,EXTEN,NULL);
X        if (!(pbuf=fopen(s,"r"))) {
X            extern int errno;
X
X            if (errno != 2) /* ENOENT */ {
X                onintr(errrec,1);
X#ifdef SMALL
X                printf("%s: error %d\n",s,errno);
X#else
X                perror(s);
X#endif
X                errhand();
X            }
X            cpystr(s,LIBLOGO,name,EXTEN,NULL);
X            if (!(pbuf = fopen(s,"r"))) {
X                onintr(errrec,1);
X                printf("You haven't told me how to %s.\n",name);
X                errhand();
X            }
X        }
X        pptr=(struct plist *)ckzmalloc(sizeof(*pptr));
X        pptr->plines=NULL;
X        pptr->procname=globcopy(nameob);
X        mfree(nameob);
X        temp=s;
X        while ( ((c=getc(pbuf)) != EOF) && (c!='\n') ) *temp++=c;
X        if (c==EOF) {
X            printf("Bad format in %s title line.\n",
X                pptr->procname->obstr);
X            errhand();
X        }
X        *temp++='\n';
X        *temp='\0';
X        title=globcopy(objcpstr(s));
X        pptr->after=proclist;
X        pptr->recdepth=1;
X        pptr->ptitle=title;
X        pptr->before=NULL;
X        if (proclist) proclist->before = pptr;
X        proclist=pptr;
X        pcell=pptr;
X    }
X    tstr = title->obstr;
Xnextarg: while((c= *tstr++)!=':' && c!='\n')
X        ;
X    if (c==':') {
X        temp=s;
X        while ((c= *tstr++)!=' ' && c!='\n') *temp++=c;
X        *temp='\0';
X        tstr--;
X        loccreate(globcopy(objcpstr(s)),&newloc);
X        argno++;
X        goto nextarg;
X    }
X    if (pptr->recdepth!=1) return;
X    olp=pflag;
X    pflag=1;
X    oldlet=letflag;
X    letflag=0;
X    olc=charib;
X    charib=0;
X    newstk=(int *)ckmalloc(PSTKSIZ*sizeof(int));
X    *newstk=0;
X    newsti=1;
X    *(newstk+newsti) = -1;    /* BH 6/25/82 in case yylex blows up */
X    itemp = '\n';
X    while ((pc = yylex()) != -1) {
X        if (pc==1) return;
X        if ((itemp == '\n') && isuint(pc)) {
X            linlab=((struct object *)yylval)->obint;
X            ltemp=(struct lincell *)ckmalloc(sizeof(*ltemp));
X            ltemp->linenum=linlab;
X            ltemp->base=newstk;
X            ltemp->index=newsti;
X            ltemp->nextline=pptr->plines;
X            pptr->plines=ltemp;
X        }
X        *(newstk+newsti++)=pc;
X        if (newsti==PSTKSIZ-1) newfr();
X        *(newstk+newsti++)=yylval;
X        if (isstored(pc)) {
X            yylval = (YYSTYPE)globcopy(yylval);
X            mfree(yylval);
X        }
X        if (newsti==PSTKSIZ-1) newfr();
X        *(newstk+newsti) = -1;
X        itemp = pc;
X    }
X    *(newstk+newsti)= -1;
X    *(newstk+PSTKSIZ-1)=0;
X    pflag=olp;
X    letflag=oldlet;
X    charib=olc;
X    fclose(pbuf);
X    onintr(errrec,1);
X    while (*newstk!=0) newstk= (int *)*newstk;
X    pptr->realbase=newstk;
X}
X
Xprocprep()
X{
X    doprep=0;
X    fbr->oldline=yyline;
X    fbr->oldbpt=getbpt;
X    getbpt=0;
X    fbr->loclist=locptr;
X    locptr=newloc;
X    newloc=NULL;
X    fbr->stk=stkbase;
X    stkbase=newstk;
X    newstk=NULL;
X    fbr->ind=stkbi;
X    stkbi=1;
X    newsti=0;
X    argno= -1;
X    fbr->oldpfg = pflag;
X    pflag=2;
X    fbr->iftest = currtest;
X    if (traceflag) intrace();
X}
X
Xfrmpop(val)
Xregister struct object *val;
X{
X    struct alist *atemp0,*atemp1,*atemp2;
X    register struct stkframe *ftemp;
X    struct lincell *ltemp,*ltemp2;
X    register i;
X    int *stemp;
X    int stval;
X
X    if (traceflag) outtrace(val);
X    if (!pcell) goto nopcell;
X    strcpy(popname,pcell->procname->obstr);
X    (pcell->recdepth)--;
X    if (pcell->recdepth==0) {
X        lfree(pcell->procname);
X        lfree(pcell->ptitle);
X        if (pcell->before) (pcell->before)->after=pcell->after;
X        else proclist=pcell->after;
X        if (pcell->after) (pcell->after)->before=pcell->before;
X        for(ltemp=pcell->plines;ltemp;ltemp=ltemp2) {
X            ltemp2=ltemp->nextline;
X            JFREE(ltemp);
X        }
X        if ((stemp=stkbase) == 0) goto nostack;
X        while (*stemp!=0) stemp= (int *)*stemp;
X        for (i=1;;i++) {
X            stval= *(stemp+i);
X            if (isstored(stval))
X            {
X                if (i==PSTKSIZ-2) {
X                    stkbase= (int *)*(stemp+PSTKSIZ-1);
X                    JFREE(stemp);
X                    stemp=stkbase;
X                    i=0;
X                }
X                lfree(*(stemp+ (++i)));
X            } else if (stval== -1) {
X                JFREE(stemp);
X                break;
X            } else {
X                if (i==PSTKSIZ-2) {
X                    stkbase= (int *)*(stemp+PSTKSIZ-1);
X                    JFREE(stemp);
X                    stemp=stkbase;
X                    i=1;
X                } else i++;
X            }
X            if (i==PSTKSIZ-2) {
X                stkbase= (int *)*(stemp+PSTKSIZ-1);
X                JFREE(stemp);
X                stemp=stkbase;
X                i=0;
X            }
X        }
X    nostack:
X        JFREE(pcell);
X    }
Xnopcell:
X    ftemp=fbr;
X    stkbase=ftemp->stk;
X    stkbi=ftemp->ind;
X    newstk=ftemp->oldnewstk;
X    atemp0=newloc;    /* BH 6/20/82 maybe never did procprep */
X    newloc=ftemp->oldnloc;
X    pflag = fbr->oldpfg;
X    atemp1=locptr;
X    locptr=ftemp->loclist;
X    argno=ftemp->argtord;
X    pcell=ftemp->prevpcell;
X    yychar=ftemp->oldyyc;
X    yylval=ftemp->oldyyl;
X    yyline=ftemp->oldline;
X    getbpt=ftemp->oldbpt;
X    currtest=ftemp->iftest;
X    fbr=ftemp->prevframe;
X    JFREE(ftemp);
X    while (atemp1) {
X        atemp2=atemp1->next;
X        if (atemp1->name) lfree(atemp1->name);
X        if (atemp1->val!=(struct object *)-1)    /* BH 2/28/80 was NULL instead of -1 */
X            lfree(atemp1->val);
X        JFREE(atemp1);
X        atemp1=atemp2;
X    }
X    while (atemp0) {
X        atemp2=atemp0->next;
X        if (atemp0->name) lfree(atemp0->name);
X        if (atemp0->val!=(struct object *)-1)
X            lfree(atemp0->val);
X        JFREE(atemp0);
X        atemp0=atemp2;
X    }
X}
X
Xproccreate(nameob)
Xregister struct object *nameob;
X{
X    register char *name;
X    char temp[16];
X    register FILDES edfd;
X    int pid;
X
X#ifndef NOTURTLE
X    if (turtdes<0) textscreen();
X#endif
X    name = token(nameob->obstr);
X    if (strlen(name)>NAMELEN) {
X        pf1("Procedure name must be no more than %d letters.",NAMELEN);
X        errhand();
X    }
X    cpystr(temp,name,EXTEN,NULL);
X    if ((edfd=open(temp,READ,0))>=0) {
X        close(edfd);
X        nputs(name);
X        puts(" is already defined.");
X        errhand();
X    }
X    if ((edfd = creat(temp,0666)) < 0) {
X        printf("Can't write %s.\n",name);
X        errhand();
X    }
X    onintr(ehand3,edfd);
X    mfree(nameob);
X    write(edfd,titlebuf,strlen(titlebuf));
X    addlines(edfd);
X    onintr(errrec,1);
X}
X
Xhelp()
X{
X    FILE *sbuf;
X
X    sbuf=fopen(HELPFILE,"r");
X    if (sbuf == NULL) {
X        printf("? Help file missing, sorry.\n");
X        return;
X    }
X    onintr(ehand2,sbuf);
X    while(putch(getc(sbuf))!=EOF)
X        ;
X    fclose(sbuf);
X    onintr(errrec,1);
X}
X
Xstruct object *describe(arg)
Xstruct object *arg;
X{
X    register char *argstr;
X    register struct lexstruct *lexp;
X    FILE *sbuf;
X    char fname[30];
X
X    if (!stringp(arg)) ungood("Describe",arg);
X    argstr = token(arg->obstr);
X    for (lexp = keywords; lexp->word; lexp++)
X         if (!strcmp(argstr,lexp->word) ||
X             (lexp->abbr && !strcmp(argstr,lexp->abbr)))
X            break;
X    if (!lexp->word) {
X        pf1("%p isn't a primitive.\n",arg);
X        errhand();
X    }
X    if (strlen(lexp->word) > 9)    /* kludge for Eunice */
X        cpystr(fname,DOCLOGO,lexp->abbr,NULL);
X    else
X        cpystr(fname,DOCLOGO,lexp->word,NULL);
X    if (!(sbuf=fopen(fname,"r"))) {
X        printf("Sorry, I have no information about %s\n",lexp->word);
X        errhand();
X    } else {
X        onintr(ehand2,sbuf);
X        while (putch(getc(sbuf))!=EOF)
X            ;
X        fclose(sbuf);
X    }
X    onintr(errrec,1);
X    mfree(arg);
X    return ((struct object *)(-1));
X}
X
Xerrwhere()
X{
X    register i =0;
X    register struct object **astk;
X    register struct plist *opc;
X
X    cboff();    /* BH 12/13/81 */
X    ibufptr=NULL;
X    if (doprep) {
X        procprep();
X        frmpop(-1);
X    }
X
X    for (astk=allocstk;i<MAXALLOC;i++)
X        if (astk[i]!=0)
X            mfree(astk[i]);
X
X    if (multarg) {
X        lfree(multarg);
X        multarg = 0;
X    }    /* BH 10/31/81 multarg isn't on astk, isn't mfreed. */
X
X#ifdef PAUSE
X    if ((errpause||pauselev) && fbr && !topf) {
X        /* I hope this pauses on error */
X        if (!pflag && !getbpt) charib=0;
X        dopause();
X    }
X    else
X#endif
X    {
X        opc = pcell;
X        if (fbr && fbr->oldline==-1) {
X            opc=fbr->prevpcell;
X        }
X        if (opc&&!topf)
X            printf("You were at line %d in procedure %s\n",
X                yyline,opc->procname->obstr);
X    }
X}
X
Xerrzap() {
X    while (thisrun)
X        unrun();
X
X    while (fbr)
X        frmpop(-1);
X
X    charib=0;
X    if(traceflag)traceflag=1;
X    topf=0;
X    yyline=0;
X    letflag=0;
X    pflag=0;
X    endflag=0;
X    rendflag=0;
X    argno= -1;
X    newstk=NULL;
X    newsti=0;
X    stkbase=NULL;
X    stkbi=0;
X    fbr=NULL;
X    locptr=NULL;
X    newloc=NULL;
X    proclist=NULL;
X    pcell=NULL;
X#ifdef PAUSE
X    pauselev = 0;
X#endif
X}
X
Xerrrec()
X{
X    /* Here on SIGQUIT */
X#ifdef PAUSE
X    if (catching)
X#endif
X        errhand();
X#ifdef PAUSE
X    flagquit++;    /* We'll catch this later */
X#endif
X}
X
Xehand2(fle)
Xregister FILE *fle;
X{
X    fclose(fle);
X    errhand();
X}
X
Xehand3(fle)
Xregister FILDES fle;
X{
X    close(fle);
X    errhand();
X}
X
Xstruct object *tracefuns = 0;
X
Xltrace() {    /* trace everything */
X    lfree(tracefuns);
X    tracefuns = (struct object *)0;
X    traceflag = 1;
X}
X
Xluntrace() {    /* trace nothing */
X    lfree(tracefuns);
X    tracefuns = (struct object *)0;
X    traceflag = 0;
X}
X
Xstruct object *sometrace(funs)
Xstruct object *funs;
X{
X    if (funs==0) {
X        luntrace();
X    } else if (!listp(funs)) {
X        ungood("Trace",funs);
X    } else {
X        tracefuns = globcopy(funs);
X        mfree(funs);
X        traceflag = 1;
X    }
X    return ((struct object *)(-1));
X}
X
Xint chktrace(procname)
Xchar *procname;
X{
X    struct object *rest;
X
X    if (tracefuns == 0) return(1);
X    for (rest=tracefuns; rest; rest=rest->obcdr) {
X        if (!stringp(rest->obcar)) continue;
X        if (!strcmp(token(rest->obcar->obstr),procname)) return(1);
X    }
X    return(0);
X}
X
Xintrace()
X{
X    register struct alist *aptr;
X
X    if (!pcell) return;
X    if (!chktrace(pcell->procname->obstr)) return;
X    indent(traceflag-1);
X    nputs(pcell->procname->obstr);
X    if (locptr && (locptr->val != (struct object *)-1)) {
X        pf1(" of %l",locptr->val);    /* BH locptr->val was inval */
X        for (aptr=locptr->next;aptr;aptr=aptr->next) {
X            if (aptr->val == (struct object *)-1) break;
X            pf1(" and %l",aptr->val);    /* was inval */
X        }
X        putchar('\n');
X    }
X    else puts(" called.");
X    fflush(stdout);
X    traceflag++;
X}
X
Xouttrace(retval)
Xregister struct object *retval;
X{
X    if (!pcell) return;
X    if (!chktrace(pcell->procname->obstr)) return;
X    if (traceflag>1) traceflag--;
X    indent(traceflag-1);
X    nputs(pcell->procname->obstr);
X    if (retval != (struct object *)-1) pf1(" outputs %l\n",retval);
X    else puts(" stops.");
X    fflush(stdout);
X}
X
Xindent(no)
Xregister int no;
X{
X    while (no--)putchar(' ');
X}
X
END_OF_logoproc.c
if test 11517 -ne `wc -c <logoproc.c`; then
    echo shar: \"logoproc.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f turtle.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"turtle.c\"
else
echo shar: Extracting \"turtle.c\" \(9873 characters\)
sed "s/^X//" >turtle.c <<'END_OF_turtle.c'
X
X#include "logo.h"
X
X#ifndef NOTURTLE
X
X#include <math.h>
X
Xextern char *getenv();
Xint turtdes; /* file descriptor for open turtle */
Xint color;    /* pen color */
Xint pendown = 0; /* nonzero with pen down */
Xint penerase = 0; /* 0=pd, 1=pe, 2=px, pendown must be nonzero */
Xint shown = 1;    /* nonzero if turtle is visible */
Xint textmode = 0;    /* not turtle off */
XNUMBER yscrunch;    /* scale factor for y */
Xstruct display *mydpy;
X
X#ifdef ATARI
X#include "atari.i"
X#endif
X
X#ifdef GIGI
X#include "gigi.i"
X#endif
X
X#ifdef ADM
X#include "admtek.i"
X#include "adm.i"
X#endif
X
X#ifdef TEK
X#ifndef ADM
X#include "admtek.i"
X#endif
X#include "tek.i"
X#endif
X
X#ifdef SUN
X#include "sun.i"
X#endif
X
XNUMBER ncheck(arg)
Xstruct object *arg;
X{
X    NUMBER val;
X
X    arg = numconv(arg,"Turtle command");
X    arg = dubconv(arg);
X    val = arg->obdub;
X    mfree(arg);
X    return(val);
X}
X
Xdpyinit() {
X    char *ttytype;
X
X    ttytype = getenv("TERM");
X#ifdef GIGI
X    if (!strcmp(ttytype,"gigi"))
X        mydpy = &gigi;
X    else
X#endif
X#ifdef ATARI
X    if (!strcmp(ttytype,"atari"))
X        mydpy = &bwatari;
X    else
X#endif
X#ifdef ADM
X    if (!strncmp(ttytype,"adm",3))
X        mydpy = &adm;
X    else
X#endif
X#ifdef TEK
X    if (!strncmp(ttytype,"tek",3))
X        mydpy = &tek;
X    else
X#endif
X#ifdef SUN
X    if (1 || !strcmp(ttytype,"sun"))    /* Sun is always a sun */
X        mydpy = &sun;
X    else
X#endif
X    {
X        printf("I don't recognize your terminal type!\n");
X        errhand();
X    }
X    pendown = 1; penerase = 0; shown = 1;
X    textmode = 0;
X    mydpy->turtx = mydpy->turty = mydpy->turth = 0.0;
X    printf(mydpy->init);
X    if (!(mydpy->cleared)) {
X        printf(mydpy->clear);
X        (*mydpy->state)('c');
X        mydpy->cleared++;
X        yscrunch = mydpy->stdscrunch;
X    }
X    turtdes = -1;
X    (*mydpy->infn)();
X    (*mydpy->drawturt)(0);
X}
X
Xstruct object *getturtle(arg)
Xregister struct object *arg;
X{
X    int lsflag[2];    /* BH 1/4/81 */
X    register char *temp,*argc;
X    char c[100];
X    char astr[20];
X
X    if (stringp(arg)) argc = arg->obstr;
X    else argc = "";
X    if (!strcmp(argc,"off")) {
X#ifdef FLOOR
X        if (turtdes>0) {
X            close (turtdes);
X            printf("Please\007 unplug the turtle\007 and put it\007 away!\n");
X        }
X#endif /* FLOOR */
X        if (turtdes<0) {
X            printf(mydpy->finish);
X            (*mydpy->outfn)();
X        }
X        turtdes = 0;
X        mfree(arg);
X        return((struct object *)(-1));
X    }
X    if (!strcmp(argc,"dpy")||!strcmp(argc,"display")) {
X
X#ifdef FLOOR
X        if (turtdes>0) {
X            close (turtdes);
X            printf("Please\007 unplug the turtle\007 and put it\007 away!\n");
X        }
X#endif /* FLOOR */
X
X        dpyinit();
X        mfree(arg);
X        return ((struct object *)(-1));
X    }
X#ifdef FLOOR
X    if (intp(arg)) {
X        sprintf(astr,FIXFMT,arg->obint);
X        argc = astr;
X    }
X    temp = c;
X    cpystr(temp,"/dev/turtle",argc,NULL);
X    if (turtdes>0) close(turtdes);
X    if((turtdes = open(c,2)) < 0) {
X        turtdes = 0;
X        pf1("Turtle %l not available.\n",arg);
X    } else printf("Please put the turtle away when you're done!\n");
X    mfree(arg);
X    return ((struct object *)(-1));
X#else
X    ungood("Turtle",arg);
X#endif /* FLOOR */
X}
X
Xdpysxy(newx,newy)
XNUMBER newx,newy;
X{
X    if ((newx < mydpy->xlow) || (newx > mydpy->xhigh) ||
X        (newy < mydpy->ylow) || (newy > mydpy->yhigh)) {
X            puts("Out of bounds!");
X            errhand();
X    }
X    if (shown) (*mydpy->drawturt)(1);
X    if (fabs(newx) < 0.01) newx = 0.0;
X    if (fabs(newy) < 0.01) newy = 0.0;
X    if (pendown)
X        (*mydpy->drawfrom)(mydpy->turtx,yscrunch*mydpy->turty);
X    mydpy->turtx = newx;
X    mydpy->turty = newy;
X    if (pendown)
X        (*mydpy->drawto)(newx,yscrunch*newy);
X    (*mydpy->state)('G');
X    if (shown) (*mydpy->drawturt)(0);
X}
X
Xdpyforw(dist)
XNUMBER dist;
X{
X    NUMBER newx,newy,deltax,deltay;
X
X    tcheck();
X    (*mydpy->txtchk)();
X    deltax = dist * sin((mydpy->turth)*3.141592654/180.0);
X    if (fabs(deltax) < 1.0e-5) deltax = 0.0;
X    deltay = dist * cos((mydpy->turth)*3.141592654/180.0);
X    if (fabs(deltay) < 1.0e-5) deltay = 0.0;
X    newx = mydpy->turtx + deltax;
X    newy = mydpy->turty + deltay;
X    dpysxy(newx,newy);
X}
X
Xstruct object *forward(arg)
Xregister struct object *arg;
X{
X    NUMBER dist;
X
X    dist = ncheck(arg);
X#ifdef FLOOR
X    if (turtdes > 0) {
X        if (dist < 0.0)
X            moveturtle('b',-6*(int)dist);
X        else
X            moveturtle('f',6*(int)dist);
X        return ((struct object *)(-1));
X    }
X#endif /* FLOOR */
X    dpyforw(dist);
X    return ((struct object *)(-1));
X}
X
Xstruct object *back(arg)
Xregister struct object *arg;
X{
X    NUMBER dist;
X
X    dist = ncheck(arg);
X#ifdef FLOOR
X    if (turtdes > 0) {
X        if (dist < 0.0)
X            moveturtle('f',-6*(int)dist);
X        else
X            moveturtle('b',6*(int)dist);
X        return ((struct object *)(-1));
X    }
X#endif /* FLOOR */
X    dpyforw(-dist);
X    return ((struct object *)(-1));
X}
X
Xdpysh(angle)
XNUMBER angle;
X{
X    (*mydpy->txtchk)();
X    if (shown) (*mydpy->drawturt)(1);
X    mydpy->turth = angle;
X    while (mydpy->turth+11.0 < 0.0) mydpy->turth += 360.0;
X    while (mydpy->turth+11.0 >= 360.0) mydpy->turth -= 360.0;
X    if (shown) (*mydpy->drawturt)(0);
X    (*mydpy->turnturt)();
X}
X
Xdpyturn(angle)
XNUMBER angle;
X{
X    tcheck();
X    dpysh(mydpy->turth + angle);
X}
X
Xstruct object *left(arg)
Xregister struct object *arg;
X{
X    NUMBER dist;
X
X    dist = ncheck(arg);
X#ifdef FLOOR
X    if (turtdes > 0) {
X        if (dist < 0.0)
X            moveturtle('r',(-2*(int)dist)/5);
X        else
X            moveturtle('l',(2*(int)dist)/5);
X        return ((struct object *)(-1));
X    }
X#endif /* FLOOR */
X    dpyturn(-dist);
X    return ((struct object *)(-1));
X}
X
Xstruct object *right(arg)
Xregister struct object *arg;
X{
X    NUMBER dist;
X
X    dist = ncheck(arg);
X#ifdef FLOOR
X    if (turtdes > 0) {
X        if (dist < 0.0)
X            moveturtle('l',(-2*(int)dist)/5);
X        else
X            moveturtle('r',(2*(int)dist)/5);
X        return ((struct object *)(-1));
X    }
X#endif /* FLOOR */
X    dpyturn(dist);
X    return ((struct object *)(-1));
X}
X
X#ifdef FLOOR
Xfcheck() {
X    if (turtdes <= 0) {
X        puts("You don't have a floor turtle!");
X        errhand();
X    }
X}
X
Xstruct object *hitoot(arg)
Xregister struct object *arg;
X{
X    NUMBER dist;
X
X    fcheck();
X    dist = ncheck(arg);
X    moveturtle('H',(15*(int)dist)/2);
X    return ((struct object *)(-1));
X}
X
Xstruct object *lotoot(arg)
Xregister struct object *arg;
X{
X    NUMBER dist;
X
X    fcheck();
X    dist = ncheck(arg);
X    moveturtle('L',(15*(int)dist)/2);
X    return ((struct object *)(-1));
X}
X
Xmoveturtle(where,arg)
Xregister int arg;
X{
X    char buff[2];
X
X    buff[0] = where;
X    while (arg >= 0400) {
X        buff[1] = 0377;
X        write(turtdes,buff,2);
X        arg -= 0377;
X    }
X    buff[1] = arg;
X    write(turtdes,buff,2);
X}
X
Xlampon() {
X    int i;
X
X    fcheck();
X    i = 'B';
X    write(turtdes,&i,2);
X}
X
Xlampoff() {
X    int i;
X
X    fcheck();
X    i = 'B'+0400;
X    write(turtdes,&i,2);
X}
X
Xstruct object *touchsense(which)
X{
X    char x;
X
X    fcheck();
X    read (turtdes,&x,1);
X    if ( (0200>>which) & x) return (true());
X    else return (false());
X}
X
Xstruct object *ftouch() {
X    return(touchsense(0));
X}
X
Xstruct object *btouch() {
X    return(touchsense(1));
X}
X
Xstruct object *ltouch() {
X    return(touchsense(2));
X}
X
Xstruct object *rtouch() {
X    return(touchsense(3));
X}
X#endif
X
Xint tcheck() {
X    if (turtdes > 0) {
X        puts("You don't have a display turtle!");
X        errhand();
X    }
X    if (turtdes == 0) dpyinit();    /* free turtle "display */
X}
X
XNUMBER posangle(angle)
XNUMBER angle;
X{
X    if (angle < 0.0) return(angle+360.0);
X    return(angle);
X}
X
Xstruct object *pencolor(pen)
Xstruct object *pen;
X{
X    NUMBER dpen;
X
X    tcheck();
X    (*mydpy->txtchk)();
X    dpen = ncheck(pen);
X    (*mydpy->penc)((int)dpen);
X    color = dpen;
X    return ((struct object *)(-1));
X}
X
Xint setcolor(pen,colorlist)
Xstruct object *pen,*colorlist;
X{
X    NUMBER number;
X    register int ipen;
X
X    tcheck();
X    (*mydpy->txtchk)();
X    number = ncheck(pen);
X    ipen = number;
X    (*mydpy->setc)(ipen,colorlist);
X}
X
Xint setxy(strx,stry)
Xstruct object *strx,*stry;
X{
X    NUMBER x,y;
X
X    tcheck();
X    (*mydpy->txtchk)();
X    x = ncheck(strx);
X    y = ncheck(stry);
X    dpysxy(x,y);
X}
X
Xstruct object *setheading(arg)
Xstruct object *arg;
X{
X    NUMBER heading;
X
X    tcheck();
X    (*mydpy->txtchk)();
X    heading = ncheck(arg);
X    dpysh(heading);
X    return ((struct object *)(-1));
X}
X
Xstruct object *xcor()
X{
X    tcheck();
X    return(localize(objdub(mydpy->turtx)));
X}
X
Xstruct object *ycor()
X{
X    tcheck();
X    return(localize(objdub(mydpy->turty)));
X}
X
Xstruct object *heading()
X{
X    tcheck();
X    return(localize(objdub(posangle(mydpy->turth))));
X}
X
Xstruct object *getpen()
X{
X    tcheck();
X    return(localize(objint(color)));
X}
X
Xstruct object *setscrunch(new)
Xstruct object *new;
X{
X    tcheck();
X    yscrunch = ncheck(new);
X    return ((struct object *)(-1));
X}
X
Xstruct object *scrunch() {
X    tcheck();
X    return(localize(objdub(yscrunch)));
X}
X
Xpenup() {
X#ifdef FLOOR
X    int i;
X
X    if (turtdes>0) {
X        i = 'P'+0400;
X        write(turtdes,&i,2);
X        return;
X    }
X#endif FLOOR
X    tcheck();
X    pendown = 0;
X    (*mydpy->state)('U');
X}
X
Xcmpendown() {
X#ifdef FLOOR
X    int i;
X
X    if (turtdes>0) {
X        i = 'P';
X        write(turtdes,&i,2);
X        return;
X    }
X#endif FLOOR
X    tcheck();
X    pendown = 1;
X    penerase = 0;
X    (*mydpy->state)('D');
X}
X
Xcmpenerase() {
X    tcheck();
X    pendown = penerase = 1;
X    (*mydpy->state)('E');
X}
X
Xpenreverse() {
X    tcheck();
X    pendown = 1;
X    penerase = 2;
X    (*mydpy->state)('R');
X}
X
Xclearscreen() {
X    tcheck();
X    (*mydpy->txtchk)();
X    printf(mydpy->clear);
X    mydpy->turtx = mydpy->turty = mydpy->turth = 0.0;
X    (*mydpy->state)('c');
X    if (shown) (*mydpy->drawturt)(0);
X}
X
Xwipeclean() {
X    tcheck();
X    (*mydpy->txtchk)();
X    printf(mydpy->clear);
X    (*mydpy->state)('w');
X    if (shown) (*mydpy->drawturt)(0);
X}
X
Xfullscreen() {
X    tcheck();
X    (*mydpy->state)('f');
X    textmode = 0;
X}
X
Xsplitscreen() {
X    tcheck();
X    (*mydpy->state)('s');
X    textmode = 0;
X}
X
Xtextscreen() {
X    tcheck();
X    (*mydpy->state)('t');
X    textmode++;
X}
X
Xshowturtle() {
X    tcheck();
X    (*mydpy->txtchk)();
X    if (!shown) (*mydpy->drawturt)(0);
X    shown = 1;
X    (*mydpy->state)('S');
X}
X
Xhideturtle() {
X    tcheck();
X    (*mydpy->txtchk)();
X    if (shown) (*mydpy->drawturt)(1);
X    shown = 0;
X    (*mydpy->state)('H');
X}
X
Xstruct object *penmode() {
X    static char *pens[] = {"pendown","penerase","penreverse"};
X
X    tcheck();
X    if (pendown) return(localize(objcpstr(pens[penerase])));
X    return(localize(objcpstr("penup")));
X}
X
Xstruct object *shownp() {
X    tcheck();
X    return(torf(shown));
X}
X
Xstruct object *towardsxy(x,y)
Xstruct object *x,*y;
X{
X    NUMBER dx,dy;
X
X    tcheck();
X    dx = ncheck(x);
X    dy = ncheck(y);
X    return(localize(objdub(posangle((double)180.0*
X        atan2(dx-(mydpy->turtx),dy-(mydpy->turty))/3.141592654))));
X}
X
X#endif
X
END_OF_turtle.c
if test 9873 -ne `wc -c <turtle.c`; then
    echo shar: \"turtle.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 3 \(of 6\).
cp /dev/null ark3isdone
MISSING=""
for I in 1 2 3 4 5 6 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 6 archives.
    echo "Now see the README"
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0